Developer CD Series 1994…tember: Reference Library/Dev.CD Sep 94.toast/Periodicals/develop/develop Issue 11/develop 11 code/The NetWork Project/Examples (Sources)/Ping.p

Text File | 1992-07-15 | 8.7 KB | 330 lines | [TEXT/MPS ]

{ © Copyright 1989,1990,1991 The NetWork Project, StatLab Heidelberg.
  © Copyright 1989,1990,1991 Joachim Lindenberg, Karlsruhe. All rights reserved. }

program Ping;

uses     MemTypes,
        QuickDraw,
        OSIntf,
        ToolIntf,
        PackIntf,
        Traps,
        SysEqu,

        NetWork,
        NetWorkLookup;

PROCEDURE InitToolBox;
VAR
    i : integer;
    p : GrafPtr;
    m : MenuHandle;

BEGIN
    MaxApplZone;
    FOR i := 1 TO 10 DO
    MoreMasters;
    InitGraf(@thePort);                {initialize QuickDraw}
    InitFonts;                           {initialize Font Manager}
    InitWindows;                       {initialize Window Manager}
    InitMenus;                           {initialize Menu Manager}
    TEInit;                            {initialize TextEdit}
    InitDialogs(NIL);                   {initialize Dialog Manager}
    InitCursor;                        {call QuickDraw to make cursor (pointer) an arrow}

    m := GetMenu (256);
    AddResMenu (m, 'DRVR');
    InsertMenu (m, 0);
    m := GetMenu (257); InsertMenu (m, 0);
    m := GetMenu (258); InsertMenu (m, 0);
    m := GetMenu (259); InsertMenu (m, 0);
    m := GetMenu (260); InsertMenu (m, 0);
    DrawMenuBar;

END;

var done,                { got cmd-Q }
    frontmost,            { frontmost process }
    beep : boolean;        { beep on message }

    others : integer;    { number of available NetWork Processors }

    MySelf : MsgAddr; signature : longint;
    last : longint;        { last address we sent something to }
    nexttime, interval : longint; { for automatic modes }
    mode, intset, msgsize : integer; { mode, interval, and size menu settings }

    { this function sends a broadcast message on all available transports }

type CharArray = packed array [0..0] of char; CharPtr = ^CharArray;

procedure ComplexBC (buffer : Ptr; size : integer);
var i : integer; trp : TransportPtr;
    Msg : MsgRec; NewMsg : MsgPtr; p : CharPtr;
begin
    i := 0; p := CharPtr (@Msg); fillchar (p^, sizeof (Msg), chr (0));
    Msg.MsgSource := MySelf; Msg.MsgDest.p := signature;
    while GetTransport (trp, i) = noErr do with trp^, Msg do begin
        if TransportBCAddr <> 0 then begin
            MsgSource.a := TransportAddr; MsgReply := MsgSource;
            MsgDest.a := TransportBCAddr; MsgTrpPtr := Trp;
            MsgReference := TimeStamp; MsgUserRefCon := 0;
            MsgCorePtr := buffer; MsgCoreSize := size;
            CheckError ('Complex BC', SendMsg (@Msg, NewMsg));
        end;
        i := i + 1;
    end;
end;

procedure DoPing;
var Msg : MsgPtr; Dest : MsgAddr; p : Ptr; i : integer;
begin
    p := NewPtr (msgsize);
    if p = nil then exit (DoPing);
    for i := 0 to msgsize-1 do CharPtr (p)^[i] := chr (i);
    if mode = 5 then ComplexBC (p, msgsize)
    else begin
        case mode of
            1 : Dest.a := 0; { local }
            2 : Dest.a := NlRandom; { 2, 3 will result in local, if no partners }
            3 : begin
                last := NlNext (last); Dest.a := last;
            end;
            4 : Dest.a := -1; { broadcast }
        end;
        Dest.p := signature;
        CheckError ('DoPing', PostMsg (Msg, nil, 0, TickCount {TimeStamp}, Dest, MySelf, nil, 0, p, msgsize));
    end;
end;

procedure KillMsg (Msg : MsgPtr);
var buffer : Ptr;
begin
    buffer := Msg^.MsgCorePtr; CheckError ('KillMsg', DestroyMsg (Msg));
    if buffer <> nil then DisposPtr (buffer);
end;

procedure ReceiveMsg (Msg : MsgPtr);
var buffer : Ptr;
begin
    buffer := NewPtr (Msg^.MsgCoreSize);
    if buffer = nil then begin
        LogMsg ('MemFail', Msg); KillMsg (Msg)
    end
    else begin
        CheckError ('Accept', AcceptMsg (Msg, buffer, Msg^.MsgCoreSize));
    end;
end;

procedure HandleMsg (Msg : MsgPtr);
var i : integer; p : Ptr;
begin
    with Msg^ do
    if (MsgResult < 0) | (BAnd (MsgCmd, tMinorMask) >= tTimeout) then KillMsg (Msg)
    else case BAnd (MsgCmd, tMajorMask) of
        tListen : begin
            CheckError ('GetMsg', GetMsg (Msg, nil, 0));
            if Visible & Spare then
            case Alert (257, nil) of
                OK : ReceiveMsg (Msg);
                Cancel : begin
                            LogMsg ('Deny', Msg); CheckError ('Deny', DestroyMsg (Msg));
                        end;
            end
            else begin
                ReceiveMsg (Msg);
                if beep then SysBeep (1);
            end;
        end;
        tGet : ProgramBreak ('how did we get there?');
        tAccept  : begin
            p := MsgCorePtr;
            if (MsgResult = 0) then
            for i := 0 to MsgCoreSize - 1 do
            if CharPtr (p)^ [i] <> chr (BAnd (i, 255)) then begin
                ProgramBreak ('message verify error'); LEAVE;
            end;
            KillMsg (Msg);
        end;
        tPost : KillMsg (Msg);
    end;
end;

procedure About;
begin
    if Alert (256, nil) = Ok then;
end;

procedure SetCreator (var signature : longint);
var d : DialogPtr; n, t : integer; s : Str255; h : Handle; box : Rect;
begin
    d := GetNewDialog (258, nil, WindowPtr (-1));
    s := 'NetP'; BlockMove (@signature, @s[1], 4);
    GetDItem (d, 3, t, h, box);
    SetIText (h, s); SelIText (d, 3, 0, 32767);
    repeat
        ModalDialog (nil, n);
        GetDItem (d, 3, t, h, box);
        GetIText (h, s);
    until (n = 2) | (length (s) = 4);
    if n = Ok then BlockMove (@s[1], @signature, 4);
    DisposDialog (d);
end;

procedure DoMenu (menu : Point);
var  s : Str255; l : longint; i : integer;
begin
    {    HiliteMenu (menu.v); { in case CmdKey }
    case menu.v of
        256 : { apple menu }
        if menu.h = 1 then About
        else begin
            GetItem (GetMHandle (256), menu.h, s);
            CheckError ('OpenDeskAcc', OpenDeskAcc (s));
        end;
        257 : case menu.h of
            1 : SetCreator (signature);
            3 : begin
                beep := not beep;
                CheckItem (GetMHandle (257), 3, beep);
            end;
            5 : DoPing;
            6 : done := true;
        end;
        258 : begin
            CheckItem (GetMHandle (258), mode, false);
            mode := menu.h;
            CheckItem (GetMHandle (258), mode, true);
        end;
        259 : begin
            CheckItem (GetMHandle (259), intset, false);
            intset := menu.h;
            CheckItem (GetMHandle (259), intset, true);
            case intset of
                3 : interval := 6;
                4 : interval := 60;
                5 : interval := 600;
                6 : interval := 3600;
                7 : interval := 7200;
            end;
            nexttime := TickCount + interval;
        end;
        260 : begin
            for i := 1 to CountMItems (GetMHandle (260)) do CheckItem (GetMHandle (260), i, false);
            CheckItem (GetMHandle (260), menu.h, true);
            GetItem (GetMHandle (260), menu.h, s);
            i := pos (' ', s); if i <> 0 then s [0] := chr (i-1);
            l := 0; StringToNum (s, l);
            msgsize := l;
        end;

    end;
    HiliteMenu (0);
end;

{ GetSleep calculates the sleep interval. It takes the following facts into account :
    - whether ping is front or back application
    - whether the lookup task needs time (note that nlsleep returns maxlongint if no task)
    - whether one of the automatic modes requires a wakeup.
}

function GetSleep : longint;
var maxsleep, sleep : longint;
begin
    if frontmost then maxsleep := 60 else maxsleep := maxlongint;
    sleep := NlGetSleep; if sleep < maxsleep then maxsleep := sleep;

    if intset <> 1 then begin { automatic modes }
        sleep := nexttime - TickCount; if sleep < 0 then sleep := 0;
        if sleep < maxsleep then maxsleep := sleep;
    end;
    GetSleep := maxsleep;
end;

procedure HandleEvents;
var w : windowPtr;
    ev : EventRecord;
begin
    if WaitNextEvent (EveryEvent, ev, GetSleep, nil) then
    case ev.what of
        mouseDown : case FindWindow (ev.where, w) of
            inMenuBar : begin
                DoMenu (Point (MenuSelect (ev.where)));
            end;
            inSysWindow : SystemClick (ev,w);
        end;
        keyDown : if BAnd (ev.modifiers, cmdKey) <> 0 then
        DoMenu (Point (MenuKey (chr (BAnd (ev.message, 255)))));
        NetWorkEvt : HandleMsg (MsgPtr (ev.message));
        app4Evt : if BAnd (ev.message, $ff000000) = $01000000 then frontmost := odd (ev.message);
    end;
end;

{ sample stack setup sequence in case we are faceless…
  - default stack sizes are
    24KB if Colour Quickdraw is installed and the application is not faceless
    8KB if Colour Quickdraw is not installed and…
    2KB if the application is faceless
  - NetWork Processor requires up to 2.5KB of stack space to operate correctly
}

procedure InitStack;
type LongPtr = ^ longint;
begin
    if LongPtr (CurStackBase)^ - LongInt (GetApplLimit) < 4096 then
    SetApplLimit (Ptr (LongPtr (CurStackBase)^ - 4096))
end;

var s : str255;
    err : integer;
    sysv : longint;

begin
    InitStack; InitToolBox;

    done := false; beep := false; last := 0; others := -1; { impossible count }

    err := InitNetWork (NetWorkEvt);
    if err <> noErr then begin
        CheckError ('InitNetWork', err);
        ExitToShell; { this program is useless without }
    end;

    CheckError ('NlInit', NlInit);

    MySelf := GetNetWorkAddr; signature := MySelf.p;

    DoMenu (Point ($01010003)); { beep }
    DoMenu (Point ($01020002)); { random }
    DoMenu (Point ($01030001)); { manual }
    DoMenu (Point ($01040001)); { 0 size }

    if Master then begin
        CheckError ('NlStart', NlStart);
        CheckError ('NlRegister', NlRegister ('','Network Ping'));
    end;

    while (not done) do begin
        CheckError ('NlTask', NlTask);
        HandleEvents;

        if Master & spare & (others <> NlCount) then begin
            others := NlCount; NumToString (others, s); insert ('Ping : Number of avail partners = ', s, 1);
            LogStrTime (s);
        end;

        if (intset <> 1) & (nexttime <= TickCount) then begin
            DoPing;
            nexttime := nexttime + interval;
        end;

    end;

    if Master then begin
        CheckError ('NlStop', NlStop);
        CheckError ('NlDeregister', NlDeregister);
    end;
    {CheckError ('NlExit', NlExit);
    CheckError ('ExitNetWork', ExitNetWork);}
end.